home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
0643A.ZIP
/
DB3TOWP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-08-18
|
22KB
|
755 lines
program dBaseIIIToSPSS;
{ dBASE III (and +) file handling routines written by
J. Troutman, Compuserve ID 74746,1567
File DBF.PAS
Version 1.1 }
{$V-}
type RegPack = record
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS : integer
end;
AnyStr = string[255];
const
ProgramTitle = 'dBASE III --> WordPerfect Merge File Conversion Utility';
DisClaimer1 = 'dBASE III and dBASE III Plus are registered trademarks of Ashton-Tate.';
DisClaimer2 = 'WordPerfect is a registered trademark of WordPerfect Incorporated.';
CopyRight =
'Copyright (C) 1986 by William J. Bliss and Northwestern University';
Version = 'Version 1.0, July 1986';
DefaultWPExt = 'DAT';
UpCaseOnly = true;
FieldDelim = ^R#10;
RecordDelim = ^E#10;
type
DOSFileNameType = string[64];
ValidSetType = set of char;
var
ControlFile,DataFile : text[4096];
DOSdBASEFile, DOSWPFile : DOSFileNameType;
Default : AnyStr;
DefLen : byte absolute Default;
Choice : char;
Trim : (Yes, No, Undefined);
{ Constants, type and variable declarations for dBASE conversion }
CONST
DB3File = 3;
DB3WithMemo = $83;
ValidTypes : SET OF Char = ['C', 'N', 'L', 'M', 'D'];
MAX_HEADER = 4129; { = maximum length of dBASE III header }
MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit }
BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }
TYPE
HeaderType = ARRAY[0..MAX_HEADER] OF Byte;
HeaderPrologType = ARRAY[0..31] OF Byte; { dBASE III header prolog }
FieldDescType = ARRAY[0..31] OF Byte; { dBASE III field definitions }
DbfRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte; { the 0 offset represents
the 'deleted' flag. }
Str255 = STRING[255];
Str80 = STRING[80];
Str64 = STRING[64];
Str10 = STRING[10];
Str8 = STRING[8];
Str2 = STRING[2];
DbfFileType = FILE;
FieldRecord = RECORD
Name : Str10;
Typ : Char;
Len : Byte;
Dec : Byte;
Off : Integer;
END;
FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF FieldRecord;
MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
MemoFileType = FILE OF MemoRecord;
DbfInfoType = RECORD
FileName : Str64;
dFile : DbfFileType;
HeadProlog : HeaderPrologType;
Updated : Boolean;
WithMemo : Boolean;
DateOfUpdate : Str8;
NumRecs : Real;
HeadLen : Integer;
RecLen : Integer;
NumFields : Integer;
Fields : FieldArray;
CurRecord : DbfRecord;
END;
var
InputFile : DbfInfoType;
procedure PaintLogo;
begin
ClrScr;
TextColor(LightBlue);
writeln(ProgramTitle,', ',Version);
writeln(CopyRight);
writeln('All Rights Reserved.');
TextColor(Yellow);
writeln;
writeln(Disclaimer1);
writeln(Disclaimer2);
writeln
end;
procedure GetChar(var ch : char);
var
registers : RegPack;
AL,AH: byte;
begin
registers.AX:=$0000;
Intr($16,registers);
ch := chr(Lo(registers.AX)) { Low order byte of AX }
end;
procedure WaitFor(ValidSet : ValidSetType;
UpperOnly : boolean;
var Response : char);
begin
repeat
GetChar(Response)
until (UpCase(Response) in ValidSet);
if UpperOnly then
write(UpCase(Response))
else
write(Response)
end;
function FileExist(var FileName : DOSFileNameType) : boolean;
var
TempFile : file;
begin
{$I-}
assign(TempFile,FileName);
reset(TempFile);
{$I-}
FileExist := (IOResult = 0)
end;
procedure OutputExists(var FileName : DOSFileNameType);
var
TempFile : file;
Response : char;
begin
writeln('File ',FileName,' already exists.');
write('Overwrite it or specify Another file (O/A)? ');
WaitFor(['O','A'],UpCaseOnly,Response);
writeln;
case UpCase(Response) of
'O' : begin
assign(TempFile,FileName);
erase(TempFile)
end;
'A' : FileName := '';
end { case }
end;
procedure GetInputFile(var FileName : DOSFileNameType);
var
Continue : boolean;
i : integer;
begin
if not FileExist(FileName) then
begin
if FileName <> '' then
begin
writeln;
writeln('File ',FileName,' not found.');
writeln
end;
repeat
write('File to convert (d:filename, .DBF assumed, RETURN to quit)? ');
read(FileName);
for i := 1 to Length(FileName) do
FileName[i] := UpCase(FileName[i]);
if (Pos('.',FileName) = 0) and (Length(FileName) > 0) then
FileName := FileName + '.DBF';
Continue := ((length(FileName) = 0) or FileExist(FileName));
writeln;
if not Continue then
begin
writeln;
write('Cannot find file ',FileName,'.');
writeln;
writeln
end
until Continue
end; { if not FileExist(FileName) }
writeln
end;
procedure GetOutputFile(var FileName : DOSFileNameType;
Default : AnyStr);
var
Continue : boolean;
Choice : char;
Phrase : AnyStr;
i : integer;
begin
Phrase := 'WordPerfect merge';
if FileName = DOSdBaseFile then
begin
writeln;
write('ERROR: ');
writeln('The output file cannot be the same as the input file.');
writeln;
FileName := ''
end;
if FileExist(FileName) then
OutputExists(FileName);
if FileName = '' then
repeat
write('Name of ',Phrase,' file (Default = ',Default,')? ');
read(FileName);
for i := 1 to Length(FileName) do
FileName[i] := UpCase(FileName[i]);
writeln;
if FileName = '' then
FileName := Default;
if FileName = DOSdBaseFile then
begin
writeln;
write('ERROR: ');
writeln('An output file cannot be the same as the input file.');
writeln;
FileName := ''
end;
if FileExist(FileName) then
OutputExists(FileName)
until length(FileName) <> 0;
end;
(* The routines in this file present some fairly general purpose tools for
accessing dBASE III and dBASE III Plus files from within a Turbo Pascal
program. There is much room for improvement: the error checking is
rudimentary, no routines to access memo files, no buffering of data,
no support for index files, etc.
The main routines are:
FUNCTION OpenDbf(VAR D : DbfInfoType;) : Integer;
FUNCTION CloseDbf(VAR D : DbfInfoType) : Integer;
PROCEDURE GetDbfRecord(VAR D : DbfInfoType; RecNum : Real);
A skeletal program would go something like:
BEGIN
{...initialize and get filename of .dbf file into FileName field
of DbfInfoType Record variable ... }
IF OpenDbf(...) { to open the file }
{... the rest of your program including calls to
GetDbfRecord as needed }
IF CloseDbf (...) { to close the file }
END.
Upon exit from the GetDbfRecord Procedure, the CurRecord field of the
DbfInfoType variable contains the current record contents. Each field
can be accessed using its offset into the CurRecord with the variable
Off in the Fields array.
See the demo program for some examples.
While I intend to upload more complete routines and better
documentation at some time, if you should have any problems with
these routines, please leave me a note.
dBASE III Database File Structure
The structure of a dBASE III database file is composed of a
header and data records. The layout is given below.
dBASE III DATABASE FILE HEADER:
+---------+-------------------+---------------------------------+
| BYTE | CONTENTS | MEANING |
+---------+-------------------+---------------------------------+
| 0 | 1 byte | dBASE III version number |
| | | (03H without a .DBT file) |
| | | (83H with a .DBT file) |
+---------+-------------------+---------------------------------+
| 1-3 | 3 bytes | date of last update |
| | | (YY MM DD) in binary format |
+---------+-------------------+---------------------------------+
| 4-7 | 32 bit number | number of records in data file |
+---------+-------------------+---------------------------------+
| 8-9 | 16 bit number | length of header structure |
+---------+-------------------+---------------------------------+
| 10-11 | 16 bit number | length of the record |
+---------+-------------------+---------------------------------+
| 12-31 | 20 bytes | reserved bytes (version 1.00) |
+---------+-------------------+---------------------------------+
| 32-n | 32 bytes each | field descriptor array |
| | | (see below) | --+
+---------+-------------------+---------------------------------+ |
| n+1 | 1 byte | 0DH as the field terminator | |
+---------+-------------------+---------------------------------+ |
|
|
A FIELD DESCRIPTOR: <------------------------------------------+
+---------+-------------------+---------------------------------+
| BYTE | CONTENTS | MEANING |
+---------+-------------------+---------------------------------+
| 0-10 | 11 bytes | field name in ASCII zero-filled |
+---------+-------------------+---------------------------------+
| 11 | 1 byte | field type in ASCII |
| | | (C N L D or M) |
+---------+-------------------+---------------------------------+
| 12-15 | 32 bit number | field data address |
| | | (address is set in memory) |
+---------+-------------------+---------------------------------+
| 16 | 1 byte | field length in binary |
+---------+-------------------+---------------------------------+
| 17 | 1 byte | field decimal count in binary |
+---------+-------------------+--------------------------------
| 18-31 | 14 bytes | reserved bytes (version 1.00) |
+---------+-------------------+---------------------------------+
The data records are layed out as follows:
1. Data records are preceeded by one byte that is a
space (20H) if the record is not deleted and an
asterisk (2AH) if it is deleted.
2. Data fields are packed into records with no field
separators or record terminators.
3. Data types are stored in ASCII format as follows:
DATA TYPE DATA RECORD STORAGE
--------- --------------------------------------------
Character (ASCII characters)
Numeric - . 0 1 2 3 4 5 6 7 8 9
Logical ? Y y N n T t F f (? when not initialized)
Memo (10 digits representing a .DBT block number)
Date (8 digits in YYYYMMDD format, such as
19840704 for July 4, 1984)
This information came directly from the Ashton-Tate Forum.
It can also be found in the Advanced Programmer's Guide available
from Ashton-Tate.
*)
(*
Notice that if you need to access more than one .DBF file simultaneously
you could declare ARRAYs of DbfFileType, DbfInfoType, etc.
*)
PROCEDURE ErrorHalt(Msg : Str80);
BEGIN
WriteLn;
WriteLn(Msg);
Halt;
END;
FUNCTION MakeReal(VAR b) : Real;
VAR
r : ARRAY[1..4] OF Byte ABSOLUTE b;
BEGIN
MakeReal := (r[1]*1)+(r[2]*256)+(r[3]*65536.0)+(r[4]*16777216.0);
END;
FUNCTION MakeInt(VAR b) : Integer;
VAR
i : Integer ABSOLUTE b;
BEGIN
MakeInt := i;
END;
FUNCTION MakeStr(b : Byte) : Str2;
VAR
i : Integer;
s : Str2;
BEGIN
i := b;
Str(i:2, s);
MakeStr := s;
END;
PROCEDURE UpdateHeader(VAR D : DbfInfoType);
TYPE
RegType = Record Case Integer of
1 : (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
2 : (AL,AH,BL,BH,CL,CH,DL,DH : Byte);
END;
VAR
Reg : RegType;
r : Real;
BEGIN
WITH D DO
BEGIN
Reg.AX := $2A00; { Get DOS Date }
Intr ($21,Reg);
HeadProlog[1] := Reg.CX - 1900; {Year}
HeadProlog[2] := Reg.DH; {Month}
HeadProlog[3] := Reg.DL; {Day}
r := NumRecs;
HeadProlog[7] := Trunc(r / 16777216.0);
r := r - (HeadProlog[7] * 16777216.0);
HeadProlog[6] := Trunc(r / 65536.0);
r := r - (HeadProlog[6] * 65536.0);
HeadProlog[5] := Trunc(r / 256);
r := r - (HeadProlog[5] * 256);
HeadProlog[4] := Trunc(r);
LongSeek(dFile,0);
{$I-} BlockWrite(dFile,HeadProlog,SizeOf(HeadProlog)); {$I+}
IF IOResult <> 0 THEN ErrorHalt('Error Closing file.');
END; {WITH}
END;
FUNCTION CloseDbf(VAR D : DbfInfoType) : Integer;
VAR
b : Byte;
BEGIN
WITH D DO
BEGIN
IF Updated THEN
BEGIN
UpdateHeader(D);
b := $1A;
LongSeek(dFile,HeadLen+NumRecs*RecLen);
BlockWrite(dFile,b,1); {Put EOF marker }
END;
{$I-} Close(dFile); {$I+}
CloseDbf := IOResult;
END; {WITH}
END;
PROCEDURE ProcessHeader(VAR Header : HeaderType;
VAR D : DbfInfoType);
PROCEDURE GetOneFieldDesc(VAR F; VAR Field : FieldRecord;
VAR Offset : Integer);
VAR
i : Integer;
FD : FieldDescType ABSOLUTE F;
BEGIN
WITH Field DO
BEGIN
i := 0;
Name := ' ';
REPEAT
Name[Succ(i)] := Chr(FD[i]);
i := Succ(i);
UNTIL FD[i] = 0;
Name[0] := Chr(i);
Typ := Char(FD[11]);
Len := FD[16];
Dec := FD[17];
Off := Offset;
Offset := Offset+Len;
IF NOT(Typ IN ValidTypes) THEN
ErrorHalt('Invalid Type in Field '+Name);
END; {WITH}
END; {GetOneFieldDesc}
VAR
o, i : Integer;
BEGIN {ProcessHeader}
WITH D DO
BEGIN
CASE Header[0] OF
DB3File : WithMemo := False;
DB3WithMemo : WithMemo := True;
ELSE
ErrorHalt('Not a valid dBASE III File.');
END; {CASE}
DateOfUpdate := MakeStr(Header[2])+'/'+MakeStr(Header[3])+'/'
+MakeStr(Header[1]);
NumRecs := MakeReal(Header[4]);
HeadLen := MakeInt(Header[8]);
RecLen := MakeInt(Header[10]); { Includes the Deleted Record Flag }
Updated := FALSE;
NumFields := 0;
FOR i := 0 TO SizeOf(HeadProlog) DO
HeadProlog[i] := Header[i];
o := 1; {Offset within dbf record of current field }
i := 32; {Index for Header }
WHILE Header[i] <> $0D DO
BEGIN
NumFields := Succ(NumFields);
GetOneFieldDesc(Header[i], Fields[NumFields], o);
i := i+32;
END; {While}
IF Header[Succ(HeadLen)] = 0 THEN
HeadLen := Succ(HeadLen);
END; {With}
END; {ProcessHeader}
PROCEDURE GetHeader(VAR D : DbfInfoType);
VAR
Result : Integer;
H : HeaderType;
BEGIN
WITH D DO
BEGIN
{$I-} BlockRead(dFile, H, MAX_HEADER, Result); {$I+}
IF IOResult <> 0 THEN
ErrorHalt('Error reading header.');
ProcessHeader(H, D);
END; {WITH}
END;
FUNCTION OpenDbf(VAR D : DbfInfoType) : Integer;
BEGIN
WITH D DO
BEGIN
Assign(dFile, FileName);
{$I-} Reset(dFile, 1); {$I+} {the '1' parameter sets the record size}
IF IOResult <> 0 THEN
ErrorHalt('Error opening data file.');
GetHeader(D);
OpenDbf := IOResult;
END; {WITH}
END;
PROCEDURE GetDbfRecord(VAR D : DbfInfoType; RecNum : Real);
VAR
Result : Integer;
BEGIN
WITH D DO
BEGIN
IF RecNum > NumRecs THEN
ErrorHalt('Tried to read past EOF.');
LongSeek(dFile, HeadLen+(RecNum-1)*RecLen);
BlockRead(dFile, CurRecord, RecLen, Result);
IF Result <> RecLen THEN
ErrorHalt('Error reading DBF File');
END; { WITH }
END; {GetDbfRecord}
PROCEDURE CreateData(VAR D : DbfInfoType);
var
r,i : integer;
PROCEDURE WriteField(VAR a; VAR F : FieldRecord);
VAR
Data : array [1..255] of char ABSOLUTE a;
Start,TempLen : integer;
BEGIN
WITH F DO
BEGIN
CASE Typ OF
'N' : begin
Start := 1;
while Data[Start] = ' ' do
Start := Start + 1;
write(DataFile,Copy(Data,Start,Len))
end;
'C',
'L' : begin
TempLen := Len;
if Trim = Yes then
while Data[TempLen] = ' ' do
TempLen := TempLen - 1;
write(DataFile,Copy(Data, 1, TempLen));
end;
'M' : ;
'D' : write(DataFile,Copy(Data, 5, 2), '/',
Copy(Data, 7, 2), '/',
Copy(Data, 1, 2));
END; {CASE}
end; {WITH F}
END; { WriteField }
BEGIN { CreateData }
WITH D DO
BEGIN
r := 1;
write(r:5,' records written to WordPerfect merge file...');
WHILE r <= NumRecs DO
BEGIN
GotoXY(1,WhereY);
write(r:5);
GetDbfRecord(D, r);
FOR i := 1 TO NumFields DO
begin
WriteField(CurRecord[Fields[i].Off], Fields[i]);
write(DataFile,FieldDelim)
end;
write(DataFile,RecordDelim);
r := r+1
END; { WHILE r }
END; { WITH D }
GotoXY(1,WhereY);
ClrEOL;
writeln((r-1):5,' records written to WordPerfect merge file ',DOSWPFile,'.')
END; { CreateData }
begin
DOSdBaseFile := ParamStr(1);
if DOSdBaseFile = '?' then
begin
ClrScr;
writeln(ProgramTitle);
writeln;
TextColor(LightBlue);
writeln('Usage: DB3WP dBaseFile[.DBF] MergeFile[.DAT] Y/N');
TextColor(Yellow);
writeln(' ',#24,' ',#24,' ',#24);
writeln(' dBASE III or WordPerfect Trim trailing');
writeln(' dBASE III + Secondary blanks from');
writeln(' input file Merge file character fields');
writeln;
writeln('You may specify an asterisk ("*") as the filename for the MergeFile.');
writeln('This will create a merge file with a filename the same as the .DBF');
writeln('file but with the appropriate extension (.DAT).');
writeln;
writeln('Example: DB3WP ADDRESS.DBF ADDRESS.DAT Y');
writeln('Result: Creates ADDRESS.DAT from ADDRESS.DBF; trims trailing blanks');
writeln(' from character fields.');
writeln;
writeln('Example: DB3SPSS ADDRESS * N');
writeln('Result: Same as above, but does not trim trailing blanks.');
writeln;
writeln('If you simply type DB3WP alone, you will be prompted for each file name and');
writeln('whether or not you wish to trim trailing blanks from character fields.');
Halt
end;
DOSWPFile := ParamStr(2);
if ParamStr(3) = '' then
Trim := Undefined
else
case UpCase(Copy(ParamStr(3),1,1)) of
'Y' : Trim := Yes;
'N' : Trim := No
else
Trim := Undefined
end;
if (DOSdBaseFile <> '') and (Pos('.',DOSdBaseFile) = 0) then
DOSdBaseFile := DOSdBaseFile + '.DBF';
if (ParamCount < 1) or FileExist(DOSWPFile) then
PaintLogo;
GetInputFile(DOSdBaseFile);
if length(DOSdBaseFile) = 0 then
halt;
Default := DOSdBaseFile;
while Default[DefLen] <> '.' do
DefLen := Pred(DefLen);
if DOSWPFile = '*' then
DOSWPFile := Default + DefaultWPExt;
GetOutputFile(DOSWPFile,Default + DefaultWPExt);
if Trim = Undefined then
begin
writeln;
write('Trim trailing blanks of character fields (Y/N)? Y');
GotoXY(WhereX-1,WhereY);
repeat
GetChar(Choice)
until UpCase(Choice) in ['Y','N',#13];
case UpCase(Choice) of
'Y',#13 : Trim := Yes;
'N' : begin
write('N');
Trim := No
end
end
end;
InputFile.FileName := DOSdBaseFile;
if OpenDBF(InputFile) <> 0 then
ErrorHalt('Error in opening file '+DOSdBaseFile);
assign(DataFile,DOSWPFile);
rewrite(DataFile);
PaintLogo;
writeln('Generating data file ',DOSWPFile,' from ',DOSdBaseFile);
CreateData(InputFile);
LowVideo;
if CloseDbf(InputFile) <> 0 then
writeln('Error closing ',DOSdBaseFile);
Close(DataFile);
writeln
end.